home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mule / mule-debug.el.z / mule-debug.el
Encoding:
Text File  |  1998-05-21  |  15.2 KB  |  455 lines
  1. ;;; mule-diag.el --- debugging functions for Mule.
  2.  
  3. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Sun Microsystems.
  5.  
  6. ;; This file is part of XEmacs.
  7.  
  8. ;; XEmacs is free software; you can redistribute it and/or modify it
  9. ;; under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; XEmacs is distributed in the hope that it will be useful, but
  14. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. ;; General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  20. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21. ;; Boston, MA 02111-1307, USA.
  22.  
  23. ;;; 93.7.28  created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
  24.  
  25. ;;; General utility function
  26.  
  27. (defun mule-debug-princ-list (&rest args)
  28.   (while (cdr args)
  29.     (if (car args)
  30.     (progn (princ (car args)) (princ " ")))
  31.     (setq args (cdr args)))
  32.   (princ (car args))
  33.   (princ "\n"))
  34.  
  35. ;;; character sets
  36.  
  37. ;;;###autoload
  38. (defun list-charsets ()
  39.   "Display a list of existing character sets."
  40.   (interactive)
  41.   (with-output-to-temp-buffer "*Charset List*"
  42.     (princ "## LIST OF CHARACTER SETS\n")
  43.     (princ
  44.      "NAME                 REGISTRY        BYTES CHARS FINAL GRAPHIC DIR\n")
  45.     (princ
  46.      "--------------------------------------------------------------------")
  47.     (dolist (charset (charset-list))
  48.       (setq charset (get-charset charset))
  49.       (princ (format
  50.           "%20s %15s %5d %5d %5d %7d %s\n"
  51.           (charset-name charset)
  52.           (charset-registry  charset)
  53.           (charset-dimension charset)
  54.           (charset-chars     charset)
  55.           (charset-final     charset)
  56.           (charset-graphic   charset)
  57.           (charset-direction charset)))
  58.       (princ "        ")
  59.       (princ "%s\n" (charset-doc-string charset)))))
  60.  
  61. ;    (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n")
  62. ;    (princ "NAME                 CCL-PROGRAMS\n")
  63. ;    (mapcar
  64. ;     (lambda (name)
  65. ;       (let ((ccl (charset-ccl-program name)))
  66. ;     (if ccl
  67. ;         (let ((i 0) (len (length ccl)))
  68. ;           (princ (format "%20s " name))
  69. ;           (while (< i len)
  70. ;         (princ (format " %x" (aref ccl i)))
  71. ;         (setq i (1+ i)))
  72. ;           (princ "\n")))))
  73. ;     (charset-list))
  74. ;    ))
  75.  
  76. ;;;###autoload
  77. (defun list-coding-system-briefly ()
  78.   "Display coding-systems currently used with a brief format in mini-buffer."
  79.   (interactive)
  80.   (let ((cs (and (fboundp 'process-coding-system) (process-coding-system)))
  81.     eol-type)
  82.     (message
  83.      "current: [FKDPp=%c%c%c%c%c%c%c%c] default: [FPp=%c%c%c%c%c%c]"
  84.      (coding-system-mnemonic buffer-file-coding-system)
  85.      (coding-system-eol-mnemonic buffer-file-coding-system)
  86.      (coding-system-mnemonic keyboard-coding-system)
  87.      (coding-system-mnemonic terminal-coding-system)
  88.      (coding-system-mnemonic (car cs))
  89.      (coding-system-eol-mnemonic (car cs))
  90.      (coding-system-mnemonic (cdr cs))
  91.      (coding-system-eol-mnemonic (cdr cs))
  92.      (coding-system-mnemonic (default-value 'buffer-file-coding-system))
  93.      (coding-system-eol-mnemonic (default-value 'buffer-file-coding-system))
  94.      (coding-system-mnemonic (car default-process-coding-system))
  95.      (coding-system-eol-mnemonic (car default-process-coding-system))
  96.      (coding-system-mnemonic (cdr default-process-coding-system))
  97.      (coding-system-eol-mnemonic (cdr default-process-coding-system))
  98.      )))
  99.  
  100. (defun princ-coding-system (code)
  101.   (princ ": ")
  102.   (princ code)
  103.   (princ " [")
  104.   (princ (char-to-string (coding-system-mnemonic code)))
  105.   (princ (char-to-string (coding-system-eol-mnemonic code)))
  106.   (princ "]\n"))
  107.  
  108. (defun todigit (flags idx &optional default-value)
  109.   (if (aref flags idx)
  110.       (if (numberp (aref flags idx)) (aref flags idx) 1)
  111.     (or default-value 0)))
  112.  
  113. (defun print-coding-system-description (code)
  114.   (let ((type (get-code-type code))
  115.     (eol (or (get-code-eol code) 1))
  116.     (flags (get-code-flags code))
  117.     line)
  118.     (setq type
  119.       (cond ((null type) 0)
  120.         ((eq type t) 2)
  121.         ((eq type 0) 1)
  122.         ((eq type 1) 3)
  123.         ((eq type 2) 4)
  124.         ((eq type 3) 5)
  125.         ((eq type 4) 6)
  126.         (t nil)))
  127.     (if (or (null type)
  128.         (get code 'post-read-conversion)
  129.         (get (get-base-code code) 'post-read-conversion)
  130.         (get code 'pre-write-conversion)
  131.         (get (get-base-code code) 'pre-write-conversion)
  132.         (eq code '*noconv*))
  133.     nil
  134.       (princ
  135.        (format "%s:%d:%c:"
  136.            code type (coding-system-mnemonic code)))
  137.       (princ (format "%d" (if (numberp eol) eol 0)))
  138.       (cond ((= type 4)
  139.          (princ
  140.           (format
  141.            ":%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d"
  142.            (todigit flags 0 -1)
  143.            (todigit flags 1 -1)
  144.            (todigit flags 2 -1)
  145.            (todigit flags 3 -1)
  146.            (todigit flags 4)
  147.            (todigit flags 5)
  148.            (todigit flags 6)
  149.            (todigit flags 7)
  150.            (todigit flags 8)
  151.            (todigit flags 9)
  152.            (todigit flags 10)
  153.            (todigit flags 11))))
  154.         ((= type 5)
  155.          (princ ":0"))
  156.         ((= type 6)
  157.          (if (and (vectorp (car flags)) (vectorp (cdr flags)))
  158.          (let (i len)
  159.            (princ ":")
  160.            (setq i 0 len (length (car flags)))
  161.            (while (< i len)
  162.              (princ (format " %x" (aref (car flags) i)))
  163.              (setq i (1+ i)))
  164.            (princ ",")
  165.            (setq i 0 len (length (cdr flags)))
  166.            (while (< i len)
  167.              (princ (format " %x" (aref (cdr flags) i)))
  168.              (setq i (1+ i))))))
  169.         (t (princ ":0")))
  170.       (princ ":")
  171.       (princ (get-code-document code))
  172.       (princ "\n"))
  173.     ))
  174.  
  175. ;;;###autoload
  176. (defun list-coding-system (&optional all)
  177.   "Describe coding-systems currently used with a detailed format.
  178. If optional arg ALL is non-nil, all coding-systems are listed in
  179. machine readable simple format."
  180.   (interactive "P")
  181.   (with-output-to-temp-buffer "*Help*"
  182.     (if (null all)
  183.     (let ((cs (and (fboundp 'process-coding-system)
  184.                (process-coding-system))))
  185.       (princ "Current:\n  buffer-file-coding-system")
  186.       (princ-coding-system buffer-file-coding-system)
  187.       (princ "  keyboard-coding-system")
  188.       (princ-coding-system keyboard-coding-system)
  189.       (princ "  terminal-coding-system")
  190.       (princ-coding-system terminal-coding-system)
  191.       (when cs
  192.         (princ "  process-coding-system (input)")
  193.         (princ-coding-system (car cs))
  194.         (princ "  process-coding-system (output)")
  195.         (princ-coding-system (cdr cs)))
  196.       (princ "Default:\n  buffer-file-coding-system")
  197.       (princ-coding-system (default-value 'buffer-file-coding-system))
  198.       (princ "  process-coding-system (input)")
  199.       (princ-coding-system (car default-process-coding-system))
  200.       (princ "  process-coding-system (output)")
  201.       (princ-coding-system (cdr default-process-coding-system))
  202.       (princ "Others:\n  buffer-file-coding-system-for-read")
  203.       (princ-coding-system buffer-file-coding-system-for-read)
  204.       (princ "Coding categories by priority:\n")
  205.       (princ (coding-priority-list)))
  206.       (princ "########################\n")
  207.       (princ "## LIST OF CODING SYSTEM\n")
  208.       (princ "## NAME(str):TYPE(int):MNEMONIC(char):EOL(int):FLAGS:DOC(str)\n")
  209.       (princ "##  TYPE = 0(no conversion),1(auto conversion),\n")
  210.       (princ "##         2(Mule internal),3(SJIS),4(ISO2022),5(BIG5),6(CCL)\n")
  211.       (princ "##  EOL = 0(AUTO), 1(LF), 2(CRLF), 3(CR)\n")
  212.       (princ "##  FLAGS =\n")
  213.       (princ "##    if TYPE = 4 then\n")
  214.       (princ "##        G0,G1,G2,G3,SHORT,ASCII-EOL,ASCII-CNTL,SEVEN,\n")
  215.       (princ "##        LOCK-SHIFT,USE-ROMAN,USE-OLDJIS\n")
  216.       (princ "##    else if TYPE = 6 then\n")
  217.       (princ "##        CCL_PROGRAM_FOR_READ,CCL_PROGRAM_FOR_WRITE\n")
  218.       (princ "##    else\n")
  219.       (princ "##        0\n")
  220.       (princ "##\n")
  221.       (let ((codings nil))
  222.     (mapatoms
  223.      (function
  224.       (lambda (arg)
  225.         (if (eq arg '*noconv*)
  226.         nil
  227.           (if (and (or (vectorp (get arg 'coding-system))
  228.                (vectorp (get arg 'eol-type)))
  229.                (null (get arg 'pre-write-conversion))
  230.                (null (get arg 'post-read-conversion)))
  231.           (setq codings (cons arg codings)))))))
  232.     (while codings
  233.       (print-coding-system-description (car codings))
  234.       (setq codings (cdr codings))))
  235.       (princ "############################\n")
  236.       (princ "## LIST OF CODING CATEGORIES (ordered by priority)\n")
  237.       (princ "## CATEGORY(str):CODING-SYSTEM(str)\n")
  238.       (princ "##\n")
  239.       (princ (coding-priority-list))
  240.       )))
  241.  
  242. ;;; FONT
  243. (defun describe-font-internal (fontinfo &optional verbose)
  244.   (let ((cs (character-set (aref fontinfo 3))))
  245.     (mule-debug-princ-list (format "Font #%02d for" (aref fontinfo 0))
  246.         (nth 6 cs) (nth 7 cs) "--"
  247.         (cond ((= (aref fontinfo 4) 0) "NOT YET OPENED")
  248.               ((= (aref fontinfo 4) 1) "OPENED")
  249.               (t "NOT FOUND")))
  250.     (mule-debug-princ-list "  request:" (aref fontinfo 1))
  251.     (if (= (aref fontinfo 4) 1)
  252.     (mule-debug-princ-list "   opened:" (aref fontinfo 2)))
  253.     (if (and verbose (= (aref fontinfo 4) 1))
  254.     (progn
  255.       (mule-debug-princ-list "     size:" (format "%d" (aref fontinfo 5)))
  256.       (mule-debug-princ-list " encoding:" (if (= (aref fontinfo 6) 0) "low" "high"))
  257.       (mule-debug-princ-list "  yoffset:" (format "%d" (aref fontinfo 7)))
  258.       (mule-debug-princ-list "  rel-cmp:" (format "%d" (aref fontinfo 8)))))
  259.     ))
  260.  
  261. ;;;###autoload
  262. (defun describe-font (fontname)
  263.   "Display information about fonts which partially match FONTNAME."
  264.   (interactive "sFontname: ")
  265.   (setq fontname (regexp-quote fontname))
  266.   (with-output-to-temp-buffer "*Help*"
  267.     (let ((fontlist (font-list)) fontinfo)
  268.       (while fontlist
  269.     (setq fontinfo (car fontlist))
  270.     (if (or (string-match fontname (aref fontinfo 1))
  271.         (and (aref fontinfo 2)
  272.              (string-match fontname (aref fontinfo 2))))
  273.         (describe-font-internal fontinfo 'verbose))
  274.     (setq fontlist (cdr fontlist))))))
  275.  
  276. ;;;###autoload
  277. (defun list-font ()
  278.   "Display a list of fonts."
  279.   (interactive)
  280.   (with-output-to-temp-buffer "*Help*"
  281.     (let ((fontlist (font-list)))
  282.       (while fontlist
  283.     (describe-font-internal (car fontlist))
  284.     (setq fontlist (cdr fontlist))))))
  285.  
  286. ;;; FONTSET
  287. (defun describe-fontset-internal (fontset-info)
  288.   (mule-debug-princ-list "### Fontset-name:" (car fontset-info) "###")
  289.   (let ((i 0) font)
  290.     (while (< i 128)
  291.       (if (>= (setq font (aref (cdr fontset-info) i)) 0)
  292.       (describe-font-internal (get-font-info font)))
  293.       (setq i (1+ i)))))
  294.  
  295. ;;;###autoload
  296. (defun describe-fontset (fontset)
  297.   "Display information about FONTSET."
  298.   (interactive
  299.    (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))))
  300.      (list (completing-read "Fontset: " fontset-list nil 'match))))
  301.   (let ((fontset-info (get-fontset-info fontset)))
  302.     (if fontset-info
  303.     (with-output-to-temp-buffer "*Help*"
  304.       (describe-fontset-internal fontset-info))
  305.       (error "No such fontset: %s" fontset))))
  306.  
  307. ;;;###autoload
  308. (defun list-fontset ()
  309.   "Display a list of fontsets."
  310.   (interactive)
  311.   (with-output-to-temp-buffer "*Help*"
  312.     (let ((fontsetlist (fontset-list 'all)))
  313.       (while fontsetlist
  314.     (describe-fontset-internal (car fontsetlist))
  315.     (setq fontsetlist (cdr fontsetlist))))))
  316.  
  317. ;;; DIAGNOSIS
  318.  
  319. (defun insert-list (args)
  320.   (while (cdr args)
  321.     (insert (or (car args) "nil") " ")
  322.     (setq args (cdr args)))
  323.   (if args (insert (or (car args) "nil")))
  324.   (insert "\n"))
  325.  
  326. (defun insert-section (sec title)
  327.   (insert "########################################\n"
  328.       "# Section " (format "%d" sec) ".  " title "\n"
  329.       "########################################\n\n"))
  330.  
  331. ;;;###autoload
  332. (defun mule-diag ()
  333.   "Show diagnosis of the current running Mule."
  334.   (interactive)
  335.   (let ((buf (get-buffer-create "*Diagnosis*")))
  336.     (save-excursion
  337.       (set-buffer buf)
  338.       (erase-buffer)
  339.       (insert "\t##############################\n"
  340.           "\t### DIAGNOSIS OF YOUR MULE ###\n"
  341.           "\t##############################\n\n"
  342.           "CONTENTS: Section 0.  General information\n"
  343.           "          Section 1.  Display\n"
  344.           "          Section 2.  Input methods\n"
  345.           "          Section 3.  Coding-systems\n"
  346.           "          Section 4.  Character sets\n")
  347.       (if window-system
  348.       (insert "          Section 5.  Fontset list\n"))
  349.       (insert "\n")
  350.  
  351.       (insert-section 0 "General information")
  352.       (insert "Mule's version: " mule-version " of " mule-version-date "\n")
  353.       (if window-system
  354.       (insert "Window-system: "
  355.           (symbol-name window-system)
  356.           (format "%s" window-system-version))
  357.     (insert "Terminal: " (getenv "TERM")))
  358.       (insert "\n\n")
  359.  
  360.       (insert-section 1 "Display")
  361.       (if (eq window-system 'x)
  362.       (let* ((alist (nth 1 (assq (selected-frame)
  363.                      (current-frame-configuration))))
  364.          (fontset (cdr (assq 'font alist))))
  365.         (insert-list (cons "Defined fontsets:" (fontset-list)))
  366.         (insert "Current frame's fontset: " fontset "\n"
  367.             "See Section 5 for more detail.\n\n"))
  368.     (insert "Coding system for output to terminal: "
  369.         (symbol-name terminal-coding-system)
  370.         "\n\n"))
  371.       (insert-section 2 "Input methods")
  372.       (if (featurep 'egg)
  373.       (let (temp)
  374.         (insert "EGG (Version " egg-version ")\n")
  375.         (insert "  jserver host list: ")
  376.         (insert-list (if (boundp 'jserver-list) jserver-list
  377.                (if (setq temp (getenv "JSERVER"))
  378.                    (list temp))))
  379.         (insert "  cserver host list: ")
  380.         (insert-list (if (boundp 'cserver-list) cserver-list
  381.                (if (setq temp (getenv "CSERVER"))
  382.                    (list temp))))
  383.         (insert "  loaded ITS mode:\n\t")
  384.         (insert-list (mapcar 'car its:*mode-alist*))
  385.         (insert "  current server:" (symbol-name wnn-server-type) "\n"
  386.             "  current ITS mode:"
  387.             (let ((mode its:*mode-alist*))
  388.               (while (not (eq (cdr (car mode)) its:*current-map*))
  389.             (setq mode (cdr mode)))
  390.               (car (car mode))))
  391.         (insert "\n")))
  392.       (insert "QUAIL (Version " quail-version ")\n")
  393.       (insert "  Quail packages: (not-yet-loaded) [current]\n\t")
  394.       (let ((l quail-package-alist)
  395.         (current (or (car quail-current-package) "")))
  396.     (while l
  397.       (cond ((string= current (car (car l)))
  398.          (insert "[" (car (car l)) "]"))
  399.         ((nth 2 (car l))
  400.          (insert (car (car l))))
  401.         (t
  402.          (insert "(" (car (car l)) ")")))
  403.       (if (setq l (cdr l)) (insert " ") (insert "\n"))))
  404.       (if (featurep 'canna)
  405.       (insert "CANNA (Version " canna-rcs-version ")\n"
  406.           "  server:" (or canna-server "Not specified") "\n"))
  407.       (if (featurep 'sj3-egg)
  408.       (insert "SJ3 (Version" sj3-egg-version ")\n"
  409.           "  server:" (get-sj3-host-name) "\n"))
  410.       (insert "\n")
  411.  
  412.       (insert-section 3 "Coding systems")
  413.       (save-excursion (list-coding-systems))
  414.       (insert-buffer "*Help*")
  415.       (goto-char (point-max))
  416.       (insert "\n")
  417.  
  418.       (insert-section 4 "Character sets")
  419.       (save-excursion (list-charsets))
  420.       (insert-buffer "*Help*")
  421.       (goto-char (point-max))
  422.       (insert "\n")
  423.  
  424.       (if window-system
  425.       (progn
  426.         (insert-section 5 "Fontset list")
  427.         (save-excursion (list-fontset))
  428.         (insert-buffer "*Help*")))
  429.  
  430.       (set-buffer-modified-p nil)
  431.       )
  432.     (let ((win (display-buffer buf)))
  433.       (set-window-point win 1)
  434.       (set-window-start win 1))
  435.     ))
  436.  
  437. ;;; DUMP DATA FILE
  438.  
  439. ;;;###autoload
  440. (defun dump-charsets ()
  441.   (list-charsets)
  442.   (set-buffer (get-buffer "*Help*"))
  443.   (let (make-backup-files)
  444.     (write-region (point-min) (point-max) "charsets.lst"))
  445.   (kill-emacs))
  446.  
  447. ;;;###autoload
  448. (defun dump-coding-systems ()
  449.   (list-coding-systems 'all)
  450.   (set-buffer (get-buffer "*Help*"))
  451.   (let (make-backup-files)
  452.     (write-region (point-min) (point-max) "coding-systems.lst"))
  453.   (kill-emacs))
  454.  
  455.